Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/dll_gen/drvplus/filetd.frm

Text File | 1994-06-06 | 17KB | 553 lines

VERSION 2.00
Begin Form FileTD
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "File Time/Date Changer"
   ClientHeight    =   5730
   ClientLeft      =   1245
   ClientTop       =   1125
   ClientWidth     =   6990
   ControlBox      =   0   'False
   Height          =   6135
   Left            =   1185
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5730
   ScaleWidth      =   6990
   Top             =   780
   Width           =   7110
   Begin CommandButton CmdDeselectAll
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Deselect All"
      Height          =   375
      Left            =   360
      TabIndex        =   1
      Top             =   5040
      Width           =   1575
   End
   Begin CommandButton CmdSelectAll
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Select All"
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   4680
      Width           =   1575
   End
   Begin CommandButton ChgDateTime
      BackColor       =   &H00C0C0C0&
      Caption         =   "Change &Both"
      Height          =   375
      Left            =   5040
      TabIndex        =   6
      Top             =   4680
      Width           =   1575
   End
   Begin CommandButton CmdNewTime
      BackColor       =   &H00C0C0C0&
      Caption         =   "New T&ime"
      Height          =   375
      Left            =   3480
      TabIndex        =   5
      Top             =   5040
      Width           =   1575
   End
   Begin CommandButton CmdNewDate
      BackColor       =   &H00C0C0C0&
      Caption         =   "New D&ate"
      Height          =   375
      Left            =   1920
      TabIndex        =   3
      Top             =   5040
      Width           =   1575
   End
   Begin CommandButton CmdChgTime
      BackColor       =   &H00C0C0C0&
      Caption         =   "Change &Time"
      Height          =   375
      Left            =   3480
      TabIndex        =   4
      Top             =   4680
      Width           =   1575
   End
   Begin CommandButton CmdChgDate
      BackColor       =   &H00C0C0C0&
      Caption         =   "Change &Date"
      Height          =   375
      Left            =   1920
      TabIndex        =   2
      Top             =   4680
      Width           =   1575
   End
   Begin TextBox Text1
      Height          =   285
      Left            =   360
      MaxLength       =   11
      TabIndex        =   8
      Text            =   "Text1"
      Top             =   1080
      Width           =   3015
   End
   Begin FileListBox File1
      Height          =   225
      Hidden          =   -1  'True
      Left            =   4920
      System          =   -1  'True
      TabIndex        =   12
      Top             =   3720
      Visible         =   0   'False
      Width           =   1575
   End
   Begin DirListBox Dir1
      Height          =   1155
      Left            =   3600
      TabIndex        =   9
      Top             =   240
      Width           =   3015
   End
   Begin DriveListBox Drive1
      Height          =   315
      Left            =   360
      TabIndex        =   10
      Top             =   240
      Width           =   3015
   End
   Begin ListBox FileList
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   1605
      Left            =   360
      MultiSelect     =   1  'Simple
      Sorted          =   -1  'True
      TabIndex        =   11
      Top             =   2760
      Width           =   6255
   End
   Begin CommandButton CmdOkay
      BackColor       =   &H00C0C0C0&
      Cancel          =   -1  'True
      Caption         =   "O &K A Y"
      Height          =   375
      Left            =   5040
      TabIndex        =   7
      Top             =   5040
      Width           =   1575
   End
   Begin Label LblFileCount
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "Label2"
      ForeColor       =   &H00800000&
      Height          =   195
      Left            =   2040
      TabIndex        =   17
      Top             =   1920
      Width           =   2895
   End
   Begin Label LblTime
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "Label3"
      ForeColor       =   &H00000080&
      Height          =   195
      Left            =   3600
      TabIndex        =   16
      Top             =   2400
      Width           =   3015
   End
   Begin Label LblDate
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "Label3"
      ForeColor       =   &H00000080&
      Height          =   195
      Left            =   360
      TabIndex        =   15
      Top             =   2400
      Width           =   3015
   End
   Begin Label LblFullPath
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "Label2"
      Height          =   195
      Left            =   360
      TabIndex        =   14
      Top             =   1560
      Width           =   6255
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Search Specification:"
      ForeColor       =   &H00800000&
      Height          =   195
      Left            =   360
      TabIndex        =   13
      Top             =   840
      Width           =   3015
   End
End
'file list box allow multiple selections

Dim PathWord As String
Dim FileSpec As String

Sub ChgDateTime_Click ()
    ChangeCount% = 0
    Screen.MousePointer = 11
    On Error GoTo BadDrive4
    For i = 0 To FileList.ListCount - 1
        If FileList.Selected(i) = True Then
            ThisDir$ = CurDir$
            pos% = InStr(FileList.List(i), Chr$(9))
            ThisFile$ = Left$(FileList.List(i), pos% - 1)
            ThisFile$ = AddSeparator(ThisDir$) + ThisFile$
            ChgYear% = Val(TheYear)
            ChgMonth% = Val(TheMonth)
            ChgDate% = Val(TheDate)
            x% = SetFileDate(ThisFile$, ChgYear%, ChgMonth%, ChgDate%)
            If x% = False Then
                Screen.MousePointer = 0
                MsgBox ThisFile$, 16, "Can Not Change Time"
                End If
            ChgHours% = Val(TheHours)
            ChgMinutes% = Val(TheMinutes)
            x% = SetFileTime(ThisFile$, ChgHours%, ChgMinutes%)
            If x% = False Then
                Screen.MousePointer = 0
                MsgBox ThisFile$, 16, "Can Not Change Time"
                End If
            ChangeCount% = ChangeCount% + 1
            End If
        Next i
    Screen.MousePointer = 0
    If ChangeCount% = 0 Then
        MsgBox "No files selected to change!", 16, "File Change Error"
        Exit Sub
        Else
        DoFileList
        End If
    Exit Sub
BadDrive4:
    Screen.MousePointer = 0
    MsgBox "Can NOT access drive!", 16, "Drive Error"
    Exit Sub
End Sub

Sub CmdChgDate_Click ()
    ChangeCount% = 0
    Screen.MousePointer = 11
    On Error GoTo BadDrive
    For i = 0 To FileList.ListCount - 1
        If FileList.Selected(i) = True Then
            ThisDir$ = CurDir$
            pos% = InStr(FileList.List(i), Chr$(9))
            ThisFile$ = Left$(FileList.List(i), pos% - 1)
            ThisFile$ = AddSeparator(ThisDir$) + ThisFile$
            ChgYear% = Val(TheYear)
            ChgMonth% = Val(TheMonth)
            ChgDate% = Val(TheDate)
            x% = SetFileDate(ThisFile$, ChgYear%, ChgMonth%, ChgDate%)
            If x% = False Then
                Screen.MousePointer = 0
                MsgBox ThisFile$, 16, "Can Not Change Time"
                End If
            ChangeCount% = ChangeCount% + 1
            End If
        Next i
    Screen.MousePointer = 0
    If ChangeCount% = 0 Then
        MsgBox "No files selected to change!", 16, "File Change Error"
        Exit Sub
        Else
        DoFileList
        End If
    Exit Sub
BadDrive:
    Screen.MousePointer = 0
    MsgBox "Can NOT access drive!", 16, "Drive Error"
    Exit Sub
End Sub

Sub CmdChgTime_Click ()
    Screen.MousePointer = 11
    ChangeCount% = 0
    On Error GoTo BadDrive2
    For i = 0 To FileList.ListCount - 1
        If FileList.Selected(i) = True Then
            ThisDir$ = CurDir$
            pos% = InStr(FileList.List(i), Chr$(9))
            ThisFile$ = Left$(FileList.List(i), pos% - 1)
            ThisFile$ = AddSeparator(ThisDir$) + ThisFile$
            ChgHours% = Val(TheHours)
            ChgMinutes% = Val(TheMinutes)
            x% = SetFileTime(ThisFile$, ChgHours%, ChgMinutes%)
            If x% = False Then
                Screen.MousePointer = 0
                MsgBox ThisFile$, 16, "Can Not Change Time"
                End If
            ChangeCount% = ChangeCount% + 1
            End If
        Next i
    Screen.MousePointer = 0
    If ChangeCount% = 0 Then
        MsgBox "No files selected to change!", 16, "File Change Error"
        Exit Sub
        Else
        DoFileList
        End If
Exit Sub
BadDrive2:
    Screen.MousePointer = 0
    MsgBox "Can NOT access drive!", 16, "Drive Error"
    Exit Sub
End Sub

Sub CmdDeselectAll_Click ()
    Screen.MousePointer = 11
    For i = 0 To FileList.ListCount - 1
        FileList.Selected(i) = False
        Next i
    Screen.MousePointer = 0
End Sub

Sub CmdNewDate_Click ()
    Screen.MousePointer = 11
    CalSel.Show 1
    Header = DateSerial(Val(TheYear), Val(TheMonth), Val(TheDate))
    TheDateWord = Format$(Header, "d mmm yyyy")
    LblDate.Caption = "Date to set:  " + TheDateWord
End Sub

Sub CmdNewTime_Click ()
Dim TempHours As Integer
Dim TempMinutes As Integer
Dim TempMeridiem As Integer
    Screen.MousePointer = 11
    TimeChg.Show 1
    TempHours = Val(TheHours)
    If TempHours > 11 Then
        TempHours = TempHours - 12
        TempMeridiem = 1
        Else
        TempMeridiem = 0
        End If
    If TempHours = 0 Then TempHours = 12
    TempMinutes = Val(TheMinutes)
    TheTimeWord = Format$(TempHours, "##") + ":" + Format$(TempMinutes, "00")
    If TempMeridiem = 1 Then
        TheTimeWord = TheTimeWord + " pm"
        Else
        TheTimeWord = TheTimeWord + " am"
        End If
    LblTime.Caption = "Time to set:  " + TheTimeWord
End Sub

Sub CmdOkay_Click ()
    Unload Me
End Sub

Sub CmdSelectAll_Click ()
    Screen.MousePointer = 11
    For i = 0 To FileList.ListCount - 1
        FileList.Selected(i) = True
        Next i
    Screen.MousePointer = 0
End Sub

Sub Dir1_Change ()
    Screen.MousePointer = 11
    ChDir dir1.Path
    LblFullPath.Caption = PathWord + LCase$(dir1.Path)
    File1.Path = dir1.Path
    DoFileList
    Screen.MousePointer = 0
End Sub

Sub DoFileList ()
    Screen.MousePointer = 11
    On Error GoTo BadFileSpec
    File1.Pattern = FileSpec
    FileList.Clear
    NbrFound% = File1.ListCount
    If NbrFound% = 0 Then
        FileWord$ = "No Matching Files Found"
        ElseIf NbrFound% = 1 Then FileWord$ = "One Matching File Found"
        Else
        FileWord$ = Format$(NbrFound%, "###,##0") + " Matching Files Found"
        End If
    LblFileCount.Caption = FileWord$
    If File1.ListCount = 0 Then
        CmdChgDate.Enabled = False
        CmdChgTime.Enabled = False
        CmdSelectAll.Enabled = False
        CmdDeselectAll.Enabled = False
        ChgDateTime.Enabled = False
        Screen.MousePointer = 0
        Exit Sub
        Else
        CmdChgDate.Enabled = True
        CmdChgTime.Enabled = True
        CmdSelectAll.Enabled = True
        CmdDeselectAll.Enabled = True
        ChgDateTime.Enabled = True
        For i = 0 To File1.ListCount - 1
            TheFileName$ = File1.List(i)
            FullPath$ = CurDir$
            FullPath$ = AddSeparator(FullPath$) + TheFileName$
            TimeStamp$ = FileDateTime(FullPath$)
            TheFileDate$ = Format$(TimeStamp$, "dd mmm yyyy")
            If Left$(TheFileDate$, 1) = "0" Then
                TheFileDate$ = " " + Right$(TheFileDate$, Len(TheFileDate$) - 1)
                End If
            TheFileTime$ = Format$(TimeStamp$, "hh:mm am/pm")
            If Left$(TheFileTime$, 1) = "0" Then
                TheFileTime$ = " " + Right$(TheFileTime$, Len(TheFileTime$) - 1)
                End If
            TheFileSize$ = Format$(FileLen(FullPath$), "###,###,##0")
            If Len(TheFileSize$) < 11 Then
                AddSpace$ = Space$(11 - Len(TheFileSize$))
                Else
                AddSpace$ = ""
                End If
            TheFileSize$ = AddSpace$ + TheFileSize$
            TheFileAttr% = GetAttr(FullPath$)
            TheAttr$ = ""
            If (TheFileAttr% And 32) <> 0 Then
                TheAttr$ = TheAttr$ + "A"
                Else
                TheAttr$ = TheAttr$ + "-"
                End If
            If (TheFileAttr% And 4) <> 0 Then
                TheAttr$ = TheAttr$ + "S"
                Else
                TheAttr$ = TheAttr$ + "-"
                End If
            If (TheFileAttr% And 2) <> 0 Then
                TheAttr$ = TheAttr$ + "H"
                Else
                TheAttr$ = TheAttr$ + "-"
                End If
            If (TheFileAttr% And 1) <> 0 Then
                TheAttr$ = TheAttr$ + "R"
                Else
                TheAttr$ = TheAttr$ + "-"
                End If
            FileList.AddItem TheFileName$ + Chr$(9) + TheFileDate$ + Chr$(9) + TheFileTime$ + Chr$(9) + TheAttr$ + Chr$(9) + TheFileSize$
            Next i
        End If
    Screen.MousePointer = 0
    Exit Sub
BadFileSpec:
    Screen.MousePointer = 0
    Beep
    MsgBox "Invalid File Specification!", 16, "Data Entry Error"
    Text1.SetFocus
    Exit Sub
End Sub

Sub Drive1_Change ()
    On Error GoTo SelDrvBad
    Screen.MousePointer = 11
    ChDrive Drive1.Drive
    dir1.Path = Drive1.Drive
    Screen.MousePointer = 0
    Exit Sub
SelDrvBad:
    Screen.MousePointer = 0
    msg$ = "Drive Error " + UCase$(Left$(Drive1.Drive, 1)) + ":"
    response = MsgBox("Can NOT Access Drive!", 21, msg$)
    If response = 4 Then
        Screen.MousePointer = 11
        Resume 0
        End If
    WinRoot
    Exit Sub
End Sub

Sub Form_Load ()
    FormCenterScreen Me
    PathWord = "Full Path = "

    TheDateWord = Format$(Now, "d mmm yyyy")
    TheMonth = Format$(Now, "m")
    TheDate = Format$(Now, "d")
    TheYear = Format$(Now, "yyyy")
    LblDate.Caption = "Date to set:  " + TheDateWord

    TheTimeWord = Format$(Now, "h:mm am/pm")
    TheHours = Format$(Now, "h")
    TheMinutes = Format$(Now, "n")
    LblTime.Caption = "Time to set:  " + TheTimeWord

    On Error GoTo BadDrive3
    LblFullPath.Caption = PathWord + LCase$(CurDir$)

    ListHscroll FileList, 40
    ReDim tabsets%(4)
    tabsets%(0) = 0
    tabsets%(1) = 16 * 4
    tabsets%(2) = 30 * 4
    tabsets%(3) = 42 * 4
    tabsets%(4) = 44 * 4
    dummy% = OutMessage(FileList.hWnd, 1043, 5, tabsets%(0))
    FileSpec = "*.*"
    Text1.Text = FileSpec
    DoFileList

    Screen.MousePointer = 0
    Exit Sub
BadDrive3:
    WinRoot
    Resume Next
End Sub

Sub Form_Paint ()
    DoForm3D Me, sunken, 3, 0
    DoForm3D Me, raised, 1, 3
    DoControl3D LblFullPath, sunken, 1
    DoControl3D LblFileCount, sunken, 1
    DoControl3D LblDate, sunken, 1
    DoControl3D LblTime, sunken, 1
End Sub

Sub Text1_GotFocus ()
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1.Text)
End Sub

Sub Text1_KeyPress (KeyAscii As Integer)
    char = Chr(KeyAscii)
    KeyAscii = Asc(UCase(char))
    If char = "\" Then KeyAscii = 0
    If char = Chr$(34) Then KeyAscii = 0
    If char = Chr$(32) Then KeyAscii = 0
    If char = ":" Then KeyAscii = 0
    If char = Chr$(13) Then
        KeyAscii = 0
        SendKeys "{TAB}"
        Exit Sub
        End If
End Sub

Sub Text1_LostFocus ()
    FileSpec = Text1.Text
    DoFileList
End Sub

Sub WinRoot ()
    Screen.MousePointer = 11
    WinDir$ = Left$(GetWinDir(), 3)
    Drive1.Drive = WinDir$
    ChDrive WinDir$
    dir1.Path = CurDir$
    LblFullPath.Caption = PathWord + LCase$(dir1.Path)
    Screen.MousePointer = 0
End Sub